perm filename SYNT.VLI[VLI,LSP] blob
sn#382064 filedate 1978-09-08 generic text, type C, neo UTF8
COMMENT ā VALID 00003 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (setq adj1 '(couleur taille qual))
C00006 00003
C00016 ENDMK
Cā;
(setq adj1 '(couleur taille qual))
(setq act '( (chat) (souris) (chien) (jean) (marie) )))
(SETQ COULEUR '(NOIR NOIRE BLANC BLANCHE))
(SETQ TAILLE '(GRAND GRANDE PETIT PETITE))
(SETQ QUAL '(BEAU BELLE LAID LAIDE))
(setq adj (append (append couleur taille) qual)))
(SETQ A)
(setq art '( le la les un une des))
(setq obj '( (pomme) (table) (lait) (pattes) (dent) ))
(setq vb ' ( (mange act aliment) (boit act fluide)
(donne a act act obj) (est sur elem obj)
(est elem) ))
(setq prepos '(sur sous dans ))
(setq jonc '(qui que quoi dont))
(setq p)
(setq app)
(setq pron '( (qui) (que) ))
(setq coord '( (et) (ou) (mais) (donc) ))
(setq table)
(setq cont '(ne n pas ni))
(de pronsu (l x2 x)
( while l
(cond ((memq (car l) jonc)
(nconc1 x (surv)))
(t (setq x (nconc1 x (nextl l)))))) x)
(de surv (ll)
(cond ((eq (car l) 'qui)
(setq ll (sub1)))
((eq (car l) 'que)
(setq ll (sub2)))
((eq (car l) 'et)
(nconc1 ll (nextl l)))
))
(de sub2 (zo zoo)
(setq zo (nconc1 zo (nextl l)))
(while (and (not (null l)) (not (assoc (car l) vb)))
(cond ((pn (car l))
(setq zo (nconc1 zo (nextl l))))
((eq (car l) 'qui)
(setq zo (nconc1 zo (sub1))))
(( eq (car l) ' que)
(setq zo (nconc1 zo (sub2))))
((eq (car l) 'et)
(setq zo (nconc1 zo (nextl l))))
(t (setq zo (nconc1 zo (nextl l)))
(setq zoo t))
))
(nconc1 zo (nextl l))
(if (and zoo (eq (car l) 'pas)) (nconc1 zo (nextl l)))
zo)
(de sub1 (zo)
(setq zo (nconc1 zo (nextl l)))
(while (and l (not (pn (car l))))
(cond ((assoc (car l) vb)
(nconc1 zo (nextl l)))
(( eq (car l) 'que)
(nconc1 zo (sub2)))
((eq (car l) 'et)
(nconc1 zo (nextl l)))
(t (nconc1 zo (nextl l)))
))
(while (and l (pn (car l)))
(nconc1 zo (nextl l)))
(cond ((eq (car l) 'qui)
(nconc1 zo (sub1)) )
(t zo) ) zo)
(de sujet (l)
(or (assq l act) (assq l obj) (assq l pron) (memq l p)))
(de vbetre (x)
(memq x '(suis es est sommes etes sont serai seras sera)))
(de pn(x)
(or (assoc x (append act obj))
(memq x (append (append art adj ) prepos))) )
(de destruct (l x z m1 z2 )
(while l
(cond ((atom (car l))
(setq x (nconc1 x (nextl l))))
((and (listp (car l)) (memq 'et (cdr l)) )
(while (not (eq (car l) 'et))
(setq m1 (nconc1 m1 (nextl l)))
)
(nextl l)
(nconc1 m1 (nextl l))
(setq z (reverse x))
(nomin z)
(setq x (subst (car p) z2 x))
(setq x (append x (sauv m1)))
(setq m1)
)
(t (setq z (reverse x))
(setq m1 (nextl l))
(nomin z)
(setq x (subst (car p) z2 x))
(setq x (nconc1 x (sauv m1)))
(setq m1)
)
)) x)
(de nomin (z )
(cond ((null z))
((sujet (car z))
(setq z2 (car z))
(setq p (cons (gensym) p))
(setq app (nconc1 app (cons (car p) (car z)))))
(t (nomin (cdr z)))
)z2)
(de sauv (b a)
(cond ((atom (car b))
(if (eq (car b) 'qui) (setq b(cons (car p) (cdr b)))
(setq b (nconc1 (cdr b) (car p)))))
(t
(while b
(setq a (nconc1 a (sauv (nextl b))))
)a)))
(de reg (l)
(cond ((null l))
((atom (car l))
(reg (cdr l)))
(t t)))
(de contrl (l x att)
(while l
(cond (( atom (car l))
(setq x (nconc1 x (nextl l))) )
((and (listp (car l)) (reg (car l)))
(setq att (nextl l))
(setq x2 (destruct att))
(setq att)
(nconc1 x (contrl x2))
(setq x2) )
(t
(setq x (nconc1 x (nextl l))) )
) ) x)
(de f (l)
(contrl (destruct (pronsu l) ) ) )
(de phrase (l)
(mf (f l)) )
(de mf (l sub princ)
(while l
(cond ((atom (car l) )
(setq princ (nconc1 princ (nextl l))) )
(t (setq sub (nconc1 sub (nextl l))))
))
(setq princ (list princ))
(while sub (setq princ (append princ (mf (nextl sub)))))
princ)
(de tri (l x y att z)
(while (not (assoc (car l) vb))
(setq x (nconc1 x (nextl l))) )
(cond ((and (vbetre (car l)) (memq (cadr l) prepos))
(nextl l)
(setq att (list (nextl l)))
(setq y l)
(setq z (append att
(append (structure x) (structure y))
))
)
((vbetre (car l))
(nextl l)
(setq x (append x l))
(setq z (structure x)) (car table))
(t (setq att (nextl l))
(setq y l)
(setq z (cons att(append (structure x) (structure y))))
)) z)
(de structure (l x z m mo moo att att2)
(while l
(cond
((or (sujet (car l)) (assoc (car l) coord))
(setq m (nconc1 m (NEXTL L))) )
((memq (car l) adj)
(setq mo (nconc1 mo (deta (car l))))
(setq moo (nconc1 moo (nextl l))) )
((memq (car l) art)
(setq x (nconc1 x (nextl l)))) ))
(SETQ M (NCONC1 M X)) (SETQ X)
(SETQ ATT (LIST M)) (SETQ M)
(cond (mo
(WHILE MO
(SETQ ATT2 (copy att))
(SETQ ATT2 (NCONC1 ATT2 (nextl moo)))
(SETQ ATT2 (CONS (NEXTL MO) ATT2))
(SETQ Z (NCONC1 Z ATT2)) (SETQ ATT2)) )
(t (setq z att)))(edit) z)
(DE DETA (L)
(COND ((MEMQ L COULEUR)
'COULEUR)
((MEMQ L TAILLE)
'TAILLE)
((MEMQ L QUAL)
'QUAL) ))
(de atribut (l)
(or (assq l art) (assq l adj)) )
(de term (ll x l r)
(setq l (entre ll))
(while l
(setq x (nextl l))
(cond ((eq (car x) 'non)
(setq r (nconc1 r (cons (car x)
(tri (cadr x))))))
(t (setq r (nconc1 r (tri x))))) ) r)
(DE NEG (L M)
(COND ((NULL L) M)
((AND (OR (EQ (CAR L) 'N)
(EQ (CAR L) 'NE))
(MEMQ 'PAS (CDR L)) )
(NEXTL L)
(SETQ A (CONS 'NON A))
(WHILE (NOT (EQ (CAR L) 'PAS))
(SETQ M (NCONC1 M (NEXTL L))) )
(NEXTL L)
(NEG L M) )
(T (SETQ M (NCONC1 M (NEXTL L)))
(NEG L M) ) ) )
(de entre (l m ll x xx)
(setq m (phrase l))
(while m
(setq ll (nextl m))
(setq l (neg ll))
(cond (a
(setq xx (nconc1 xx (append a (list l))))
(setq a))
(t (setq xx (nconc1 xx l))))) xx)
(de edit ()
(cond ((memq (car z) adj1)
(setq table (cons z table))
(setq z (caar z)))
(t z)))